unit wvLogging;

interface

uses
  System.SysUtils, System.SyncObjs, System.Classes, System.Generics.Collections, Data.SqlExpr, Data.DBXJSON;

const
  DATABASE_FILENAME = 'log.db';
  DATABASE_TABLENAME = 'Log';
  DATABASE_TABLENAMEPATTERN = '%LOG%';

type
  TLog = class;

  TMsgType = (mtException, mtAlert, mtHint);

  TLogAcceptMessageProc = procedure(AData: TJSONValue) of object;

  ILogMessage = interface
    function GetCode: Integer;
    function GetDate: TDateTime;
    function GetID: Integer;
    function GetLocation: String;
    function GetMsg: String;
    function GetMsgType: TMsgType;

    property ID: Integer read GetID;
    property MsgType: TMsgType read GetMsgType;
    property Date: TDateTime read GetDate;
    property Location: String read GetLocation;
    property Code: Integer read GetCode;
    property Msg: String read GetMsg;

    function ToJSON: TJSONArray;
  end;

  TLogMessage = class(TInterfacedObject, ILogMessage)
  private
    FID: Integer;
    FMsgType: TMsgType;
    FDate: TDateTime;
    FLocation: String;
    FCode: Integer;
    FMsg: String;

    function GetCode: Integer;
    function GetDate: TDateTime;
    function GetID: Integer;
    function GetLocation: String;
    function GetMsg: String;
    function GetMsgType: TMsgType;
  public
    property ID: Integer read GetID;
    property MsgType: TMsgType read GetMsgType;
    property Date: TDateTime read GetDate;
    property Location: String read GetLocation;
    property Code: Integer read GetCode;
    property Msg: String read GetMsg;

    constructor Create(AID: Integer; AMsgType: TMsgType; const ADate: TDateTime; const ALocation: String; ACode: Integer; const AMsg: String); overload;
    constructor Create(Value: TJSONValue); overload;
    constructor Create(Stream: TStream); overload;

    function ToJSON: TJSONArray;
  end;

  TLogMessageList = class(TList<ILogMessage>)
  public
    constructor Create(Stream: TStream);
  end;

  TLogHandler = class(TThread)
  private
    FLog: TLog;
    FQueue: TQueue<ILogMessage>;
    FLock: TCriticalSection;
    FEvent: TEvent;

    function Get: ILogMessage;
  public
    constructor Create(ALog: TLog);
    destructor Destroy; override;

    procedure Add(ALogMessage: ILogMessage);
    procedure Execute; override;
    procedure Process(ALogMessage: ILogMessage); virtual; abstract;
  end;

  TLogNotifier = class(TLogHandler)
  public
    procedure Process(ALogMessage: ILogMessage); override;
  end;

  TLogWriter = class(TLogHandler)
  private
    FLogNotifier: TLogNotifier;
    FQuery: TSQLQuery;
  public
    constructor Create(ALog: TLog);
    destructor Destroy; override;

    procedure Process(ALogMessage: ILogMessage); override;
  end;

  TLog = class
  private
    FConnection: TSQLConnection;
    FUserConnection: Boolean;
    FTableName: String;
    FCurrentID: Integer;
    FBuildIDLock: TCriticalSection;
    FLogWriter: TLogWriter;

    FAcceptMessageProc: TLogAcceptMessageProc;

    procedure InitDatabase;
    procedure InitTable;

    function CreateQuery: TSQLQuery;
    function BuildID: Integer;

  public
    constructor Create(AConnection: TSQLConnection; const ATableName: String);
    destructor Destroy; override;

    procedure RegisterAcceptMessageProc(AProc: TLogAcceptMessageProc);

    function ExecuteQuery(const SQL: String): TStream;

    procedure Send(const Msg: String); overload;
    procedure Send(const Location, Msg: String); overload;
    procedure Send(From: TObject; Value: Exception); overload;
    procedure Send(From: TObject; const Location: string; Value: Exception); overload;
    procedure Send(From: TObject; const Location, Msg: string; AMsgType: TMsgType = mtAlert); overload;
    procedure Send(MsgType: TMsgType; const Msg: String); overload;
    procedure Send(MsgType: TMsgType; const Location, Msg: String); overload;
    procedure Send(const Location, Msg: String; Code: Integer); overload;
    procedure Send(const Msg: String; Code: Integer); overload;
    procedure Send(Value: Exception); overload;
    procedure Send(const Location: String; Value: Exception); overload;
  end;

function Log: TLog;
procedure LogSetConnection(AConnection: TSQLConnection; const ATableName: String = DATABASE_TABLENAME);

implementation

uses
  System.Variants, System.DateUtils, Data.DbxSqlite, Data.DBXCommon, wvGeneralMethods, wvStrings;

var
  _Log: TLog;
  _Connection: TSQLConnection;
  _TableName: String;
  _InitLock: TCriticalSection;

function Log: TLog;
begin
  if _Log = nil then begin
    _InitLock.Enter;
    try
      _Log := TLog.Create(_Connection, _TableName);
      if not _Log.FUserConnection then
        _Log.InitDatabase;
      _Log.InitTable;
    finally
      _InitLock.Leave;
    end;
  end;
  result := _Log;
end;

procedure LogSetConnection(AConnection: TSQLConnection; const ATableName: String);
begin
  _Connection := AConnection;
  _TableName := ATableName;
end;

{ TLog }

constructor TLog.Create(AConnection: TSQLConnection; const ATableName: String);
begin
  FBuildIDLock := TCriticalSection.Create;
  FAcceptMessageProc := nil;
  FUserConnection := AConnection <> nil;
  if FUserConnection then
    FConnection := AConnection
  else
    FConnection := TSQLConnection.Create(nil);
  FTableName := ATableName;
  FCurrentId := 1;
  FLogWriter := TLogWriter.Create(Self);
  FLogWriter.Start;
end;

function TLog.CreateQuery: TSQLQuery;
begin
  result := TSQLQuery.Create(nil);
  result.SQLConnection := FConnection;
end;

destructor TLog.Destroy;
begin
  FLogWriter.Free;
  if not FUserConnection then
    FConnection.Free;
  FBuildIDLock.Free;
  inherited;
end;

function TLog.ExecuteQuery(const SQL: String): TStream;
  procedure record_to_stream(query: TSQLQuery; stream: TStream);
  begin
    ToStream(query.FieldByName('ID').AsInteger, stream);
    ToStream(Byte(query.FieldByName('Type').AsInteger), stream);
    ToStream(SQLiteDateTimeToDateTime(query.FieldByName('Date').AsLargeInt), stream);
    ToStream(query.FieldByName('Location').AsString, stream);
    ToStream(query.FieldByName('Code').AsInteger, stream);
    ToStream(query.FieldByName('Message').AsString, stream);
  end;
var
  query: TSQLQuery;
begin
  result := TMemoryStream.Create;
  try
    if not FConnection.Connected then
      ToStream(Integer(0), result)
    else begin
      query := CreateQuery;
      try
        query.SQL.Text := SQL.Replace(DATABASE_TABLENAMEPATTERN, FTableName, [rfIgnoreCase]);
        query.Open;
        ToStream(query.RecordCount, result);
        while not query.Eof do begin
          record_to_stream(query, result);
          query.Next;
        end;
      finally
        query.Free;
      end;
    end;
  except
    result.Free;
    raise;
  end;
end;

function TLog.BuildID: Integer;
begin
  FBuildIDLock.Enter;
  try
    result := FCurrentId;
    Inc(FCurrentId);
  finally
    FBuildIDLock.Leave;
  end;
end;

procedure TLog.InitDatabase;
begin
  FConnection.DriverName := 'Sqlite';
  FConnection.Params.Values['DataBase'] := DATABASE_FILENAME;
  FConnection.Params.Values['FailIfMissing'] := 'False';
  FConnection.Params.Values['ColumnMetaDataSupported'] := 'False';
  try
    FConnection.Open;
  except
    raise Exception.CreateFmt(sConst.Exceptions[9], [DATABASE_FILENAME]);
  end;
end;

procedure TLog.InitTable;
const
  index_tempate = 'create %sindex if not exists [ind_%s_%s] on [%1:s](%s)';
var
  query: TSQLQuery;
  transaction: TDBXTransaction;
begin
  if not FConnection.Connected then exit;
  query := CreateQuery;
  try
    transaction := FConnection.BeginTransaction;
    try
      query.SQL.Text := Format('create table if not exists [%s](' +
        'ID integer not null,' +
        'Type integer not null,' +
        'Date int64 not null,' +
        'Location varchar(255) not null,'+
        'Code integer not null,' +
        'Message varchar(255) not null' +
        ')', [FTableName]);
      query.ExecSQL;
      query.SQL.Text := Format(index_tempate, ['unique ', FTableName, 'ID']);
      query.ExecSQL;
      query.SQL.Text := Format(index_tempate, [EmptyStr, FTableName, 'Type']);
      query.ExecSQL;
      query.SQL.Text := Format(index_tempate, [EmptyStr, FTableName, 'Date']);
      query.ExecSQL;
      FConnection.CommitFreeAndNil(transaction);
    except
      FConnection.RollbackFreeAndNil(transaction);
      raise;
    end;
    query.SQL.Text := Format('select max(id) as id from [%s]', [FTableName]);
    query.Open;
    if not query.Eof then
      if not query.Fields[0].IsNull then
        FCurrentId := query.Fields[0].AsInteger + 1;
  finally
    query.Free;
  end;
end;

procedure TLog.RegisterAcceptMessageProc(AProc: TLogAcceptMessageProc);
begin
  FAcceptMessageProc := AProc;
end;

procedure TLog.Send(From: TObject; const Location: string; Value: Exception);
begin
  FLogWriter.Add(TLogMessage.Create(BuildID, mtException, Now, From.UnitName+'.'+From.ClassName+'.'+Location, 0, Value.Message));
end;

procedure TLog.Send(From: TObject; Value: Exception);
begin
  FLogWriter.Add(TLogMessage.Create(BuildID, mtException, Now, From.UnitName+'.'+From.ClassName, 0, Value.Message));
end;

procedure TLog.Send(const Location: String; Value: Exception);
begin
  Send(mtException, Location, Value.Message);
end;

procedure TLog.Send(From: TObject; const Location, Msg: string; AMsgType: TMsgType);
begin
  FLogWriter.Add(TLogMessage.Create(BuildID, AMsgType, Now, From.UnitName+'.'+From.ClassName+'.'+Location, 0, Msg));
end;

procedure TLog.Send(MsgType: TMsgType; const Location, Msg: String);
begin
  FLogWriter.Add(TLogMessage.Create(BuildID, MsgType, Now, Location, 0, Msg));
end;

procedure TLog.Send(const Location, Msg: String);
begin
  FLogWriter.Add(TLogMessage.Create(BuildID, mtHint, Now, Location, 0, Msg));
end;

procedure TLog.Send(MsgType: TMsgType; const Msg: String);
begin
  FLogWriter.Add(TLogMessage.Create(BuildID, MsgType, Now, EmptyStr, 0, Msg));
end;

procedure TLog.Send(const Msg: String);
begin
  FLogWriter.Add(TLogMessage.Create(BuildID, mtHint, Now, EmptyStr, 0, Msg));
end;

procedure TLog.Send(const Location, Msg: String;
  Code: Integer);
begin
  FLogWriter.Add(TLogMessage.Create(BuildID, mtException, Now, Location, Code, Msg));
end;

procedure TLog.Send(const Msg: String; Code: Integer);
begin
  FLogWriter.Add(TLogMessage.Create(BuildID, mtException, Now, EmptyStr, Code, Msg));
end;

procedure TLog.Send(Value: Exception);
begin
  Send(mtException, Value.Message);
end;

{ TLogMessage }

constructor TLogMessage.Create(AID: Integer; AMsgType: TMsgType; const ADate: TDateTime;
  const ALocation: String; ACode: Integer; const AMsg: String);
begin
  FID := AID;
  FDate := ADate;
  FLocation := ALocation;
  FCode := ACode;
  FMsg := AMSg;
end;

constructor TLogMessage.Create(Value: TJSONValue);
var
  arr: TJSONArray;
  dt: Int64;
begin
  try
    if not (Value is TJSONArray) then
      raise Exception.CreateFmt(sConst.Exceptions[10], [ClassName + '.Create']);
    arr := Value as TJSONArray;
    FID := TJSONNumber(arr.Get(0)).AsInt;
    FMsgType := TMsgType(TJSONNumber(arr.Get(1)).AsInt);
    dt := TJSONNumber(arr.Get(2)).AsInt64;
    FDate := PDateTime(@dt)^;
    FLocation := TJSONString(arr.Get(3)).Value;
    FCode := TJSONNumber(arr.Get(4)).AsInt;
    FMsg := TJSONString(arr.Get(5)).Value;
  except
    Free;
    raise;
  end;
end;

constructor TLogMessage.Create(Stream: TStream);
begin
  try
    FID := ReadInt(Stream);
    FMsgType := TMsgType(ReadByte(Stream));
    FDate := ReadDateTime(Stream);
    FLocation := ReadStr(Stream);
    FCode := ReadInt(Stream);
    FMsg := ReadStr(Stream);
  except
    Free;
    raise;
  end;
end;

function TLogMessage.GetCode: Integer;
begin
  result := FCode;
end;

function TLogMessage.GetDate: TDateTime;
begin
  result := FDate;
end;

function TLogMessage.GetID: Integer;
begin
  result := FID;
end;

function TLogMessage.GetLocation: String;
begin
  result := FLocation;
end;

function TLogMessage.GetMsg: String;
begin
  result := FMsg;
end;

function TLogMessage.GetMsgType: TMsgType;
begin
  result := FMsgType;
end;

function TLogMessage.ToJSON: TJSONArray;
begin
  result := TJSONArray.Create;
  try
    result.AddElement(TJSONNumber.Create(FID));
    result.AddElement(TJSONNumber.Create(Integer(FMsgType)));
    result.AddElement(TJSONNumber.Create(PInt64(@FDate)^));
    result.AddElement(TJSONString.Create(FLocation));
    result.AddElement(TJSONNumber.Create(FCode));
    result.AddElement(TJSONString.Create(FMsg));
  except
    result.Free;
    raise;
  end;
end;

{ TLogMessageList }

constructor TLogMessageList.Create(Stream: TStream);
var
  i, len: Integer;
begin
  inherited Create;
  try
    len := ReadInt(Stream);
    for i := 0 to len - 1 do
      Add(TLogMessage.Create(Stream));
  except
    Free;
    raise;
  end;
end;

{ TLogWriter }

procedure TLogHandler.Add(ALogMessage: ILogMessage);
begin
  FLock.Enter;
  try
    FQueue.Enqueue(ALogMessage);
  finally
    FLock.Leave;
  end;
  FEvent.SetEvent;
end;

constructor TLogHandler.Create(ALog: TLog);
begin
  inherited Create(True);
  FLog := ALog;
  FQueue := TQueue<ILogMessage>.Create;
  FLock := TCriticalSection.Create;
  FEvent := TEvent.Create(nil, False, False, EmptyStr);
end;

destructor TLogHandler.Destroy;
begin
  Terminate;
  FEvent.SetEvent;
  while not Finished do
    sleep(0);
  FQueue.Free;
  FLock.Free;
  FEvent.Free;
  inherited;
end;

procedure TLogHandler.Execute;
var
  lm: ILogMessage;
  i: Integer;
begin
  while not Terminated do begin

    FEvent.WaitFor(INFINITE);

    while FQueue.Count > 0 do begin
      lm := Get;
      if lm <> nil then Process(lm);
    end;

    if Terminated then break;
  end;
end;

function TLogHandler.Get: ILogMessage;
begin
  FLock.Enter;
  try
    if FQueue.Count <> 0 then
      exit(FQueue.Dequeue);
  finally
    FLock.Leave;
  end;
  result := nil;
end;

{ TLogWriter }

constructor TLogWriter.Create(ALog: TLog);
begin
  inherited;
  FLogNotifier := TLogNotifier.Create(ALog);
  FLogNotifier.Start;
  FQuery := ALog.CreateQuery;
end;

destructor TLogWriter.Destroy;
var
  lh, q: TObject;
begin
  lh := FLogNotifier;
  q := FQuery;
  inherited;
  lh.Free;
  q.Free;
end;

procedure TLogWriter.Process(ALogMessage: ILogMessage);
begin
  if not Terminated then
    FLogNotifier.Add(ALogMessage);

  if not FLog.FConnection.Connected then exit;

  try
    FQuery.SQL.Text := Format('insert into [%s](ID,Type,Date,Location,Code,Message)values(%d,%d,%d,%s,%d,%s)', [
        FLog.FTableName,
        ALogMessage.ID,
        Integer(ALogMessage.MsgType),
        DateTimeToSQLiteDateTime(ALogMessage.Date),
        AnsiQuotedStr(ALogMessage.Location, '"'),
        ALogMessage.Code,
        AnsiQuotedStr(ALogMessage.Msg, '"')
    ]);
    FQuery.ExecSQL;
  except
  end;
end;

{ TLogNotifier }

procedure TLogNotifier.Process(ALogMessage: ILogMessage);
begin
  if Assigned(FLog.FAcceptMessageProc) then
    try
      FLog.FAcceptMessageProc(ALogMessage.ToJSON);
    except
    end;
end;

initialization
  _Log := nil;
  _Connection := nil;
  _TableName := DATABASE_TABLENAME;
  _InitLock := TCriticalSection.Create;

finalization
  _Log.Free;
  _InitLock.Free;

end.
